PROBLEMA INT
(CEOI - Polonia, iulie 1997)
Intervale intregi

Un interval intreg [a,b], a<b, este multimea tuturor numerelor intregi care 
incep cu a si se termina cu b.

Problema
Scrieti un program care:
- citeste numarul de intervale si descrierile lor din fisierul text INT.IN;
- gaseste cea mica multime care contine cel putin doua numere din fiecare interval;
- scrie cardinalul acestei multimi in fisierul text INT.OUT.

Intrare
Prima linie a fisierului INT.IN contine numarul de intervale n, 1<n<10000. 
Fiecare din urmatoarele n linii contine doua numere intregi a si b (0<a<b<10000) 
separate printr-un spatiu. Ele reprezinta inceputul respectiv sfarsitul unui 
interval.

Iesirea
Programul scrie pe prima linie a fisierului INT.OUT un numar intreg. Acesta 
reprezinta cardinalul celei mai mici multimi care contine cel putin cate doua 
numere din fiecare interval.

Exemplu
Pentru intrarea 
4
3 6
2 4
0 2
4 7
iesirea corecta este:
4

S-au dat 11 teste, fiecare cotat cu cate 2 puncte.
Timp limita per test: 2 sec.
======================================
Solutia 1 (Angel Proorocu - Ploiesti)
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+}
{$M 16384,0,655360}

program Intervale;

   uses crt;

   type q=^ref;
        ref=record
         a,b:integer;
         urm:q;
        end;

   var a:array[0..10000]of q;
       n,nr,p1,p2:integer;
       f:text;

procedure ReadData;
   var i,j,k:integer;
       p,c:q;
   begin
    assign(f,'int.in');
    reset(f);
    readln(f,n);
    for i:=0 to 10000 do a[i]:=nil;
    for i:=1 to n do
     begin
      new(p);
      readln(f,p^.a,p^.b);
      p^.urm:=nil;
      if a[p^.a]=nil then a[p^.a]:=p
       else
        begin
         c:=a[p^.a];
         while c^.urm<>nil do c:=c^.urm;
         c^.urm:=p;
        end;
     end;
    close(f);
    nr:=0; p1:=10001; p2:=10001;
    for i:=10000 downto 0 do if a[i]<>nil then
     begin
      c:=a[i];
      while c<>nil do
       begin
        if c^.b<p2 then
        if c^.a=p1 then
         begin
          inc(nr);
          p2:=c^.b;
         end
        else
        if c^.b>=p1 then
         begin
          inc(nr);
          p2:=p1;
          p1:=c^.a;
         end
        else
         if c^.b<p1 then
          begin
           nr:=nr+2;
           p1:=c^.a;
           p2:=c^.a+1;
          end;
         c:=c^.urm;
       end;
     end;
     assign(f,'int.out');
     rewrite(f);
     writeln(f,nr);
     close(f);
   end;

begin
 ReadData;
end.
----------------------------
Solutia 2 (Bogdan Batog - Bucuresti)
var
   fil                          :text;
   n,i,j,f,c,p                  :integer;
   a,b,u                        :array[-1..10000] of integer;

Procedure Swap(i,j:integer);
var t:integer;
begin
     t:=a[i]; a[i]:=a[j]; a[j]:=t;
     t:=b[i]; b[i]:=b[j]; b[j]:=t
end;

Procedure InterSect(i,j:integer);
var li,ls:integer;
begin
     if a[i]>a[j] then li:=a[i] else li:=a[j];
     if b[i]>b[j] then ls:=b[j] else ls:=b[i];
     if ls>li then
     begin
          a[j]:=li;
          b[j]:=ls;
          a[i]:=-1;
          b[i]:=-1;
     end;
end;

begin
     assign(fil,'INT.IN');
     reset(fil);
     readln(fil,n);
     for i:=1 to n do readln(fil,a[i],b[i]);
     close(fil);

     for i:=2 to n do
     begin
          c:=i;
          p:=c div 2;
          while p>0 do
          begin
               if a[c]>a[p] then Swap(c,p) else c:=0;
               c:=p;
               p:=p div 2;
          end;
     end;

     for i:=n downto 2 do
     begin
          Swap(i,1);
          p:=1;
          c:=2;
          while c<i do
          begin
               if (c+1<i) and (a[c+1]>a[c]) then inc(c);
               if a[c]>a[p] then Swap(c,p) else c:=i;
               p:=c;
               c:=c*2
          end;
     end;
     for i:=1 to n-1 do InterSect(i,i+1);
     f:=0;
     fillchar(u,sizeof(u),0);
     for i:=1 to n do
      if (a[i]<>-1) and (b[i]<>-1) then
      begin
           u[b[i]]:=1;
           inc(f);
           if u[a[i]]=0 then inc(f)
      end;
     assign(fil,'INT.OUT');
     rewrite(fil);
     writeln(fil,f);
     close(fil)
end.
--------------------------
Solutia 3 (Cristian Cadar - Bucuresti)
uses crt;
type
    list=^reco;
    reco=
         record
               inf:integer;
               urm:list;
         end;
    tip_vector=array[0..10000] of list;
    vector=^tip_vector;
var
   ic,sc:vector;
   nr,ult,penult,b,i,j,k,l,n:integer;
   f:text;
   st:string;
   p:list;

procedure citire;
begin
     clrscr;
     write('Fisier intrare:');
     readln(st);
     assign(f,st);
     reset(f);
     readln(f,n);
     new(ic);
     new(sc);
     for i:=0 to 10000 do
         ic^[i]:=nil;
     for k:=1 to n do
         begin
              readln(f,i,j);
              if ic^[j]=nil
                 then
                     begin
                          new(p);
                          p^.inf:=i;
                          p^.urm:=nil;
                          ic^[j]:=p;
                          sc^[j]:=p;
                     end
                 else
                     begin
                          new(p);
                          p^.inf:=i;
                          p^.urm:=nil;
                          sc^[j]^.urm:=p;
                          sc^[j]:=p;
                     end;
         end;
     close(f);
end;

procedure prelucrare;
begin
     nr:=0;
     ult:=-1;penult:=-1;
     for b:=0 to 10000 do
         if ic^[b]<>nil
            then
                begin
                     p:=ic^[b];
                     while p<>nil do
                        begin
                             if (ult<p^.inf) and (penult<p^.inf)
                                then
                                    begin
                                         inc(nr,2);
                                         ult:=b;
                                         penult:=b-1;
                                    end
                                else
                                    if (ult>=p^.inf) and (penult<p^.inf)
                                       then
                                           begin
                                                inc(nr,1);
                                                penult:=ult;
                                                ult:=b;
                                           end;
                             p:=p^.urm;
                        end;
                end;
     writeln(nr);
end;

begin
     citire;
     prelucrare;
end.
----------------------------------
Solutia 4 (Dragos Vingarzan - Cugir)
var fi,fo:text;
    a,b,c:array [1..10000] of word;
    i,j,k,l,m,n,max:word;
begin
 assign(fi,'int.in');
 assign(fo,'int.out');
 reset(fi);
 rewrite(fo);
 readln(fi,n);
 max:=0;
 for i:=1 to n do
  begin
   readln(fi,a[i],b[i]);
   if a[i]>max then max:=a[i];
  end;
 fillchar(c,max,0);
 for i:=1 to n do
  if c[a[i]]=0 then c[a[i]]:=b[i]
               else if b[i]<c[a[i]] then c[a[i]]:=b[i];
 m:=0;
 for i:=0 to max do
  if c[i]<>0 then
   begin
    inc(m);
    a[m]:=i;
    b[m]:=c[i];
    if m=n then break;
   end;
 i:=1;
 while i<>m do
 begin
  if b[i]>=a[i+1] then begin
                       a[i]:=a[i+1];
                       if b[i]<b[i+1] then b[i]:=b[i]
                                      else b[i]:=b[i+1];
                       for j:=i+1 to m-1 do
                        begin
                         a[j]:=a[j+1];
                         b[j]:=b[j+1];
                        end;
                       dec(m);
                      end
                 else begin
                       inc(i);
                      end;
 end;
 writeln(fo,m*2);
 close(fi);
 close(fo);
end.
---------------------------
Solutia 5 (Tudor Leu - Focsani)
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+}
{$M 16384,0,655360}
uses crt;
{const ni='int.in';
      no='int.out';}
type interval=record
                    a,b:integer;
              end;
     sir=array[1..10000] of interval;
var x:sir;
    y:^sir;
    i,j,k,l,m,n,qq:integer;
    s:interval;
    sw:boolean;
    ni,no,ss:string;
procedure citeste;
begin
     assign(input,ni);reset(input);
     readln(n);
     for i:=1 to n do readln(x[i].a,x[i].b);
end;
procedure crheap(i,n:integer);
begin
     repeat
        if (2*i+1<=n) and
        ((x[2*i+1].b<x[2*i].b) or
         ((x[2*i].b=x[2*i+1].b) and (x[2*i+1].a<x[2*i].a))) then j:=2*i+1
                                                            else j:=2*i;
        sw:=true;
        if (x[i].b>x[j].b) or
           ((x[i].b=x[j].b) and (x[i].a>x[j].a)) then begin
                                                        s:=x[i];
                                                        x[i]:=x[j];
                                                        x[j]:=s;
                                                        i:=j;
                                                        sw:=false;
                                                      end;
     until (2*i>n) or sw;
end;
procedure heapsort;
begin
     for i:=n div 2 downto 1 do crheap(i,n);
     m:=n;new(y);
     while m>0 do begin
        y^[n-m+1]:=x[1];
        x[1]:=x[m];
        m:=m-1;
        crheap(1,m);
     end;
end;
procedure rezolva;
begin
     heapsort;
     m:=0;k:=-1;l:=-1;
     for i:=1 to n do
        if l<y^[i].a then begin m:=m+2;l:=y^[i].b;k:=y^[i].b-1 end
                     else
        if k<y^[i].a then begin m:=m+1;if l<y^[i].b then begin k:=l;l:=y^[i].b end
                                                    else k:=l-1;
                          end;
end;
procedure scrie;
begin
     assign(output,no);rewrite(output);
     writeln(m);
     close(output);	
end;
begin
     for qq:=0 to 11 do begin
       str(qq,ss);
       ni:='int'+ss+'.in';
       no:='int'+ss+'.out';
       citeste;
       rezolva;
       scrie;
     end;
end.
-----------------------------
Solutia 6 (Virgil Serbanuta - Focsani)
var int:array[1..10000] of record
                        c1,c2:word;
                        end;
    n:word;

procedure citire;
var i:word;
begin
readln(n);
for i:=1 to n do
    readln(int[i].c1,int[i].c2);
end;

procedure sortare;
type  aa=^ab;
      ab=record
         a:word;
         p:aa;
         end;
     t=array[0..10000] of aa;
var sort1,sort2:^t;
    i,j:word;
    p,p1:pointer;
    a:aa;
begin
mark(p);
getmem(sort1,sizeof(sort1^));
mark(p1);
fillchar(sort1^,sizeof(sort1^),0);
for i:=1 to n do
    begin
    getmem(a,sizeof(ab));
    a^.a:=int[i].c2;
    a^.p:=sort1^[int[i].c1];
    sort1^[int[i].c1]:=a;
    end;
j:=0;
for i:=0 to 10000 do
    while sort1^[i]<>nil do
          begin
          inc(j);
          int[j].c1:=i;
          int[j].c2:=sort1^[i]^.a;
          sort1^[i]:=sort1^[i]^.p;
          end;
release(p1);
fillchar(sort1^,sizeof(sort1^),0);
for i:=1 to n do
    begin
    getmem(a,sizeof(ab));
    a^.a:=int[i].c1;
    a^.p:=sort1^[int[i].c2];
    sort1^[int[i].c2]:=a;
    end;
j:=n+1;
for i:=10000 downto 0 do
    while sort1^[i]<>nil do
          begin
          dec(j);
          int[j].c2:=i;
          int[j].c1:=sort1^[i]^.a;
          sort1^[i]:=sort1^[i]^.p;
          end;
release(p1);
release(p);
end;

procedure rezolva;
var i,j,k,l:integer;
begin
j:=0;
k:=-1;
l:=-1;
for i:=1 to n do
    begin
    if int[i].c1>k then begin
       k:=int[i].c2;
       inc(j);
       if k=l then dec(k);
       end;
    if int[i].c1>l then begin
       l:=int[i].c2;
       inc(j);
       if k=l then dec(k);
       end;
    end;
writeln(j);
end;

begin
assign(input,'int.in');
reset(input);
assign(output,'int.out');
rewrite(output);
citire;
sortare;
rezolva;
end.
-------------------------
Solutia 7 (Mihai Stroe - Bucuresti)
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
{$M 65520,0,655360}

const
  NMax = 10000;

type
  List = array[1..NMax] of word;



procedure QuickSort(var A,B: List; Lo, Hi: Integer);

   procedure Sort(l, r: Integer);
     var
     i, j, x, y: integer;
     begin
       i := l; j := r; x := a[(l+r) DIV 2];
       repeat
         while a[i] < x do inc(i);
         while x < a[j] do dec(j);
         if i <= j then
            begin
              y := a[i]; a[i] := a[j]; a[j] := y;
              y := b[i]; b[i] := b[j]; b[j] := y;
              inc(i); dec(j);
            end;
         until i > j;
         if l < j then Sort(l, j);
         if i < r then Sort(i, r);
     end;

begin {QuickSort};
  Sort(Lo,Hi);
end;




var x,y,i,j,k,l,m,n,min,max,mp,mm:longint;
    lo,hi:list;
    fi,fo:text;
    s:string;

procedure readdata;
begin
  readln(fi,n);
  for i:=1 to n do
      readln(fi,lo[i],hi[i]);
end;

procedure solve;
begin
  quicksort(hi,lo,1,n);
  x:=-1;y:=-1;m:=0;
  for i:=1 to n do
      if (x<lo[i]) and(y<lo[i])then
         begin
           x:=hi[i]-1;
           y:=hi[i];
           inc(m,2);
         end
         else
      if (x<lo[i]) and(y>=lo[i])then
         begin
           x:=y;
           y:=hi[i];
           inc(m);
         end;
  writeln(fo,m);
end;

begin
  assign(fi,'int.in');
  assign(fo,'int.out');
  assign(fo,'');
  reset(fi);
  rewrite(fo);
  readdata;
  solve;
  close(fi);
  close(fo);
end.
-------------------------
Solutia 8 (Valentin Gheorghita - Ploiesti)
program intervale_ceoi;
uses crt;
type list=array[1..10000,1..2] of integer;
var a:list;
    nr,n:integer;

procedure citire;
 var f:text;
     nume:string;
     i:integer;
 begin
  write('Introduceti numele fisierului de intrare : ');
  readln(nume);
  assign(f,nume);
  reset(f);
  readln(f,n);
  for i:=1 to n do readln(f,a[i,1],a[i,2]);
  close(f);
 end;

procedure ordonare(l, r: Integer);
var
  i, j, x, y: integer;
begin
  i := l; j := r; x := a[(l+r) DIV 2,2];
  repeat
    while a[i,2] < x do i := i + 1;
    while x < a[j,2] do j := j - 1;
    if i <= j then
    begin
      y := a[i,2]; a[i,2] := a[j,2]; a[j,2] := y;
      y := a[i,1]; a[i,1] := a[j,1]; a[j,1] := y;
      i := i + 1; j := j - 1;
    end;
  until i > j;
  if l < j then ordonare(l, j);
  if i < r then ordonare(i, r);
end;

procedure calcul;
 var x,y,z,i:integer;
 begin
  nr:=0;
  x:=-1;
  y:=-1;
  for i:=1 to n do
   begin
    if x>y then begin
                 z:=x;
                 x:=y;
                 y:=z;
                end;
    if a[i,1]>x then begin
                      x:=a[i,2];
                      nr:=nr+1;
                     end;
    if a[i,1]>y then begin
                      y:=a[i,2]-1;
                      nr:=nr+1;
                     end;
   end;
 end;

begin
 citire;
 ordonare(1,n);
 calcul;
 writeln(nr);
end.
-----------------------------------
Solutia 9 (Vlad Adomnicai - Iasi)
program intt;
type inte=record
           a,b:integer;
          end;
var m:array[1..10000] of inte;
    nr,i,p,q,n:integer;
    fin,fout:text;

procedure QuickSort(Lo, Hi: Integer);
procedure Sort(l, r: Integer);
var
  i, j, x: integer;
  y:inte;
begin
  i := l; j := r; x := m[(l+r) DIV 2].b;
  repeat
    while m[i].b < x do i := i + 1;
    while x < m[j].b do j := j - 1;
    if i <= j then
    begin
      y := m[i]; m[i] := m[j]; m[j] := y;
      i := i + 1; j := j - 1;
    end;
  until i > j;
  if l < j then Sort(l, j);
  if i < r then Sort(i, r);
end;
begin
  Sort(Lo,Hi);
end;

begin
 assign(fin,'int.in');assign(fout,'out.in');
 reset(fin);rewrite(fout);
 readln(fin,n);
 for i:=1 to n do
  readln(fin,m[i].a,m[i].b);
 close(fin);
 quicksort(1,n);
 p:=-1;q:=-1;
 nr:=0;
 for i:=1 to n do
  begin
   if (p<m[i].a) or (p>m[i].b) then
    begin
     if q=m[i].b then
      p:=q-1
     else
      p:=m[i].b;
     nr:=nr+1;
    end;
   if (q<m[i].a) or (q>m[i].b) then
    begin
     if p=m[i].b then
      q:=p-1
     else
      q:=m[i].b;
     nr:=nr+1;
    end;
  end;
 writeln(fout,nr);
 close(fout);
end.
--------------------------------
